Linux Cubed Series 2: Applications/Linux Cubed Series 2 - Applications.iso/editors/emacs/xemacs/xemacs-1.006/xemacs-1/lib/xemacs-19.13/lisp/prim/subr.el

Text File | 1995-08-18 | 21.9 KB | 670 lines

;;; subr.el --- basic lisp subroutines for XEmacs

;;; Copyright (C) 1985, 1986, 1992, 1994 Free Software Foundation, Inc.
;;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
;;; Copyright (C) 1995 Sun Microsystems.

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Synched up with: FSF 19.28.

;;; Code:


;;;; Lisp language features.

(defmacro lambda (&rest cdr)
  "Return a lambda expression.
A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
self-quoting; the result of evaluating the lambda expression is the
expression itself.  The lambda expression may then be treated as a
function, i. e. stored as the function value of a symbol, passed to
funcall or mapcar, etcetera.
ARGS should take the same form as an argument list for a `defun'.
DOCSTRING should be a string, as described for `defun'.  It may be omitted.
INTERACTIVE should be a call to the function `interactive', which see.
It may also be omitted.
BODY should be a list of lisp expressions."
  ;; Note that this definition should not use backquotes; subr.el should not
  ;; depend on backquote.el.
  ;; #### - I don't see why.  So long as backquote.el doesn't use anything
  ;; from subr.el, there's no problem with using backquotes here.  --Stig
  (list 'function (cons 'lambda cdr)))

;; FSF19 emits calls to defalias instead of fset in .elc files.
(define-function 'defalias 'define-function)
(define-function 'not 'null)
(define-function 'eql 'eq)
(if (not (fboundp 'numberp))
    (define-function 'numberp 'integerp)) ; different when floats


;;;; Hook manipulation functions.

(defun run-hooks (&rest hooklist)
  "Takes hook names and runs each one in turn.  Major mode functions use this.
Each argument should be a symbol, a hook variable.
These symbols are processed in the order specified.
If a hook symbol has a non-nil value, that value may be a function
or a list of functions to be called to run the hook.
If the value is a function, it is called with no arguments.
If it is a list, the elements are called, in order, with no arguments."
  (while hooklist
    (let ((sym (car hooklist)))
      (and (boundp sym)
       (symbol-value sym)
       (let ((value (symbol-value sym)))
         (if (and (listp value) (not (eq (car value) 'lambda)))
         (while value
           (funcall (car value))
           (setq value (cdr value)))
           (funcall value)))))
    (setq hooklist (cdr hooklist))))

;; FSFmacs says:
;; It is best not to depend on the value return by `run-hook-with-args',
;; as that may change.

(defun run-hook-with-args (hook &rest args)
  "Run HOOK with the specified arguments ARGS.
HOOK should be a symbol, a hook variable.  If HOOK has a non-nil
value, that value may be a function or a list of functions to be
called to run the hook.  If the value is a function, it is called with
the given arguments and its return value is returned.  If it is a
list, the elements are called, in order, with the given arguments,
and a list of the each function's return value is returned."
  (and (boundp hook)
       (symbol-value hook)
       (let ((value (symbol-value hook)))
     (if (and (listp value) (not (eq (car value) 'lambda)))
         (mapcar #'(lambda (foo) (apply foo args))
             value)
       (apply value args)))))

(defun run-special-hook-with-args (hook &rest args)
  "Run HOOK with the specified arguments, returning the first non-nil value.
HOOK should be a symbol, a hook variable.  If HOOK has a non-nil
value, that value may be a function or a list of functions to be
called to run the hook.  If the value is a function, it is called with
the given arguments and its return value is returned.  If it is a
list, the elements are called, in order, with the given arguments,
until one of them returns non-nil, and this value is returned."
  (and (boundp hook)
       (symbol-value hook)
       (let ((value (symbol-value hook)))
     (if (and (listp value) (not (eq (car value) 'lambda)))
         (let (retval)
           (while (and value
               (not (setq retval (apply (car value) args))))
         (setq value (cdr value)))
           retval)
       (apply value args)))))

;; Tell C code how to call this function.
(setq run-hooks 'run-hooks)

(defun add-hook (hook function &optional append)
  "Add to the value of HOOK the function FUNCTION.
FUNCTION is not added if already present.
FUNCTION is added (if necessary) at the beginning of the hook list
unless the optional argument APPEND is non-nil, in which case
FUNCTION is added at the end.

HOOK should be a symbol, and FUNCTION may be any valid function.  If
HOOK is void, it is first set to nil.  If HOOK's value is a single
function, it is changed to a list of functions."
  ;(interactive "SAdd to hook-var (symbol): \naAdd which function to %s? ")
  (if (not (boundp hook)) (set hook nil))
  ;; If the hook value is a single function, turn it into a list.
  (let ((old (symbol-value hook)))
    (if (or (not (listp old)) (eq (car old) 'lambda))
    (setq old (list old)))
    (if (member function old)
    nil
      (set hook (if append
            (append old (list function)) ; don't nconc
          (cons function old))))))

(defun remove-hook (hook function)
  "Remove from the value of HOOK the function FUNCTION.
HOOK should be a symbol, and FUNCTION may be any valid function.  If
FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
list of hooks to run in HOOK, then nothing is done.  See `add-hook'."
  (if (or (not (boundp hook))        ;unbound symbol, or
      (null (symbol-value hook))    ;value is nil, or
      (null function))        ;function is nil, then
      nil                ;Do nothing.
    (let ((hook-value (symbol-value hook)))
      (if (consp hook-value)
      ;; don't side-effect the list
      (setq hook-value (delete function (copy-sequence hook-value)))
    (if (equal hook-value function)
        (setq hook-value nil)))
      (set hook hook-value))))

;; called by Fkill_buffer()
(defvar kill-buffer-hook nil
  "Function or functions to be called when a buffer is killed.
The value of this variable may be buffer-local.
The buffer about to be killed is current when this hook is run.")

;; in C in FSFmacs
(defvar kill-emacs-hook nil
  "Function or functions to be called when `kill-emacs' is called,
just before emacs is actually killed.")


;;;; List functions.

(defalias 'first 'car)
(defalias 'rest 'cdr)
(defalias 'endp 'null)

(defsubst second (x)
  "Return the second element of the list LIST."
  (car (cdr x)))

(defsubst third (x)
  "Return the third element of the list LIST."
  (car (cdr (cdr x))))

(defsubst fourth (x)
  "Return the fourth element of the list LIST."
  (nth 3 x))

(defsubst fifth (x)
  "Return the fifth element of the list LIST."
  (nth 4 x))

(defsubst sixth (x)
  "Return the sixth element of the list LIST."
  (nth 5 x))

(defsubst seventh (x)
  "Return the seventh element of the list LIST."
  (nth 6 x))

(defsubst eighth (x)
  "Return the eighth element of the list LIST."
  (nth 7 x))

(defsubst ninth (x)
  "Return the ninth element of the list LIST."
  (nth 8 x))

(defsubst tenth (x)
  "Return the tenth element of the list LIST."
  (nth 9 x))

(defsubst caar (x)
  "Return the `car' of the `car' of X."
  (car (car x)))

(defsubst cadr (x)
  "Return the `car' of the `cdr' of X."
  (car (cdr x)))

(defsubst cdar (x)
  "Return the `cdr' of the `car' of X."
  (cdr (car x)))

(defsubst cddr (x)
  "Return the `cdr' of the `cdr' of X."
  (cdr (cdr x)))

(defsubst caaar (x)
  "Return the `car' of the `car' of the `car' of X."
  (car (car (car x))))

(defsubst caadr (x)
  "Return the `car' of the `car' of the `cdr' of X."
  (car (car (cdr x))))

(defsubst cadar (x)
  "Return the `car' of the `cdr' of the `car' of X."
  (car (cdr (car x))))

(defsubst caddr (x)
  "Return the `car' of the `cdr' of the `cdr' of X."
  (car (cdr (cdr x))))

(defsubst cdaar (x)
  "Return the `cdr' of the `car' of the `car' of X."
  (cdr (car (car x))))

(defsubst cdadr (x)
  "Return the `cdr' of the `car' of the `cdr' of X."
  (cdr (car (cdr x))))

(defsubst cddar (x)
  "Return the `cdr' of the `cdr' of the `car' of X."
  (cdr (cdr (car x))))

(defsubst cdddr (x)
  "Return the `cdr' of the `cdr' of the `cdr' of X."
  (cdr (cdr (cdr x))))

(defsubst caaaar (x)
  "Return the `car' of the `car' of the `car' of the `car' of X."
  (car (car (car (car x)))))

(defsubst caaadr (x)
  "Return the `car' of the `car' of the `car' of the `cdr' of X."
  (car (car (car (cdr x)))))

(defsubst caadar (x)
  "Return the `car' of the `car' of the `cdr' of the `car' of X."
  (car (car (cdr (car x)))))

(defsubst caaddr (x)
  "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
  (car (car (cdr (cdr x)))))

(defsubst cadaar (x)
  "Return the `car' of the `cdr' of the `car' of the `car' of X."
  (car (cdr (car (car x)))))

(defsubst cadadr (x)
  "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
  (car (cdr (car (cdr x)))))

(defsubst caddar (x)
  "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
  (car (cdr (cdr (car x)))))

(defsubst cadddr (x)
  "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
  (car (cdr (cdr (cdr x)))))

(defsubst cdaaar (x)
  "Return the `cdr' of the `car' of the `car' of the `car' of X."
  (cdr (car (car (car x)))))

(defsubst cdaadr (x)
  "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
  (cdr (car (car (cdr x)))))

(defsubst cdadar (x)
  "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
  (cdr (car (cdr (car x)))))

(defsubst cdaddr (x)
  "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
  (cdr (car (cdr (cdr x)))))

(defsubst cddaar (x)
  "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
  (cdr (cdr (car (car x)))))

(defsubst cddadr (x)
  "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
  (cdr (cdr (car (cdr x)))))

(defsubst cdddar (x)
  "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
  (cdr (cdr (cdr (car x)))))

(defsubst cddddr (x)
  "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
  (cdr (cdr (cdr (cdr x)))))

(defun last (x &optional n)
  "Returns the last link in the list LIST.
With optional argument N, returns Nth-to-last link (default 1)."
  (if n
      (let ((m 0) (p x))
    (while (consp p) (setq m (1+ m)) (pop p))
    (if (<= n 0) p
      (if (< n m) (nthcdr (- m n) x) x)))
    (while (consp (cdr x)) (pop x))
    x))

(defun butlast (x &optional n)
  "Returns a copy of LIST with the last N elements removed."
  (if (and n (<= n 0)) x
    (nbutlast (copy-sequence x) n)))

(defun nbutlast (x &optional n)
  "Modifies LIST to remove the last N elements."
  (let ((m (length x)))
    (or n (setq n 1))
    (and (< n m)
     (progn
       (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
       x))))

;;; these are just so convenient in while loops...  The CL package will
;;; overload these with compatible but more powerful cousins.

(defmacro push (val list)
  "Insert VAL at the head of LIST.
Analogous to (setq LIST (cons VAL LIST))."
  `(setq ,list (cons ,val ,list)))

(defmacro pop (list)
  "Remove and return the head of LIST.
Analogous to (prog1 (car LIST) (setq LIST (cdr LIST)))."
  `(prog1 (car ,list) (setq ,list (cdr ,list))))

;; not obsolete.
(define-function 'rplaca 'setcar)
(define-function 'rplacd 'setcdr)


;;;; Mapping functions.

(defun some (__predicate __seq)
  "Return true if PREDICATE is true of any element of SEQ.
If so, return the true (non-nil) value returned by PREDICATE."
  (let ((__x nil))
    (while (and __seq
        (not (setq __x (funcall __predicate (pop __seq))))))
    __x))

(defun every (__predicate __seq)
  "Return true if PREDICATE is true of every element of SEQ."
  (while (and __seq (funcall __predicate (car __seq)))
    (setq __seq (cdr __seq)))
  (null __seq))

(defun notany (__predicate __seq)
  "Return true if PREDICATE is false of every element of SEQ."
  (not (apply 'some __predicate __seq)))

(defun notevery (__predicate __seq)
  "Return true if PREDICATE is false of some element of SEQ."
  (not (apply 'every __predicate __seq)))

(defun mapvector (__function __seq)
  "Apply FUNCTION to each element of SEQ, making a vector of the results.
The result is a vector of the same length as SEQ.
SEQ may be a list, a vector or a string."
  (let* ((len (length __seq))
     (vec (make-vector len 'nil))
     (i 0))
    (while (< i len)
      (aset vec i (funcall __function (cond ((listp __seq)
                         (nth i __seq))
                        (t (aref __seq i)))))
      (setq i (+ i 1)))
    vec))


;;;; Set functions -- less powerful equivalents of the Common Lisp ones.

(defun adjoin (item list)
  "Add ITEM to LIST (unless it's already there) and return the new list."
  (if (memq item list) list (cons item list)))

(defun union (list1 list2)
  "Return a list of elements that appear in either LIST1 or LIST2."
  (cond ((null list1) list2) ((null list2) list1)
    ((equal list1 list2) list1)
    (t
     (while list2
       (setq list1 (adjoin (car list2) list1))
       (setq list2 (cdr list2)))
     list1)))

(defun intersection (list1 list2)
  "Return a list of elements that appear in both LIST1 and LIST2."
  (and list1 list2
       (if (equal list1 list2) list1
     (let ((result nil))
       (while list2
         (if (memq (car list2) list1)
         (setq result (cons (car list2) result)))
         (setq list2 (cdr list2)))
       result))))

(defun set-difference (list1 list2)
  "Return a list of elements of LIST1 that do not appear in LIST2."
  (if (or (null list1) (null list2)) list1
    (let ((list1 (copy-sequence list1)))
      (while list2
    (setq list1 (delq (car list2) list1))
    (setq list2 (cdr list2)))
      list1)))

(defun set-exclusive-or (list1 list2)
  "Return a list of elements that appear in exactly one of LIST1 and LIST2."
  (cond ((null list1) list2) ((null list2) list1)
    ((equal list1 list2) nil)
    (t (append (set-difference list1 list2)
           (set-difference list2 list1)))))

(defun subsetp (list1 list2)
  "True if every element of LIST1 also appears in LIST2."
  (cond ((null list1) t) ((null list2) nil)
    ((equal list1 list2) t)
    (t (while (and list1
               (memq (car list1) list2))
         (setq list1 (cdr list1)))
       (null list1))))

;;;; String functions.

(defun replace-in-string (str regexp newtext &optional literal)
  "Replaces all matches in STR for REGEXP with NEWTEXT string.
Optional LITERAL non-nil means do a literal replacement.
Otherwise treat \\ in NEWTEXT string as special:
  \\& means substitute original matched text,
  \\N means substitute match for \(...\) number N,
  \\\\ means insert one \\."
  (if (not (stringp str))
      (error "(replace-in-string): First argument must be a string: %s" str))
  (if (stringp newtext)
      nil
    (error "(replace-in-string): 3rd arg must be a string: %s"
       newtext))
  (let ((rtn-str "")
    (start 0)
    (special)
    match prev-start)
    (while (setq match (string-match regexp str start))
      (setq prev-start start
        start (match-end 0)
        rtn-str
        (concat
          rtn-str
          (substring str prev-start match)
          (cond (literal newtext)
            (t (mapconcat
             (function
               (lambda (c)
                 (if special
                 (progn
                   (setq special nil)
                   (cond ((eq c ?\\) "\\")
                     ((eq c ?&)
                      (substring str
                             (match-beginning 0)
                             (match-end 0)))
                     ((and (>= c ?0) (<= c ?9))
                      (if (> c (+ ?0 (length
                               (match-data))))
                          ;; Invalid match num
                          (error "(replace-in-string) Invalid match num: %c" c)
                        (setq c (- c ?0))
                        (substring str
                               (match-beginning c)
                               (match-end c))))
                     (t (char-to-string c))))
                   (if (eq c ?\\) (progn (setq special t) nil)
                 (char-to-string c)))))
             newtext ""))))))
    (concat rtn-str (substring str start))))

(defun split-string (string pattern)
  "Return a list of substrings of STRING which are separated by PATTERN."
  (let (parts (start 0))
    (while (string-match pattern string start)
      (setq parts (cons (substring string start (match-beginning 0)) parts)
        start (match-end 0)))
    (nreverse (cons (substring string start) parts))
    ))

(defmacro with-output-to-string (&rest forms)
  "Collect output to `standard-output' while evaluating FORMS and return
it as a string."
  ;; by "William G. Dubuque" <[e-mail]> w/ mods from Stig
  (` (save-excursion
       (set-buffer (get-buffer-create " *string-output*"))
       (setq buffer-read-only nil)
       (buffer-disable-undo (current-buffer))
       (erase-buffer)
       (let ((standard-output (current-buffer)))
     (,@ forms))
       (prog1
       (buffer-string)
     (erase-buffer)))))

(defun insert-face (string face)
  "Insert STRING and highlight with FACE.  Returns the extent created."
  (let ((p (point)) ext)
    (insert string)
    (setq ext (make-extent p (point)))
    (set-extent-face ext face)
    ext))

;; not obsolete.
(define-function 'string= 'string-equal)
(define-function 'string< 'string-lessp)
(define-function 'int-to-string 'number-to-string)
(define-function 'string-to-int 'string-to-number)


;;;; Miscellanea.

(defun ignore (&rest ignore)
  "Do nothing and return nil.
This function accepts any number of arguments, but ignores them."
  (interactive)
  nil)

(defun error (&rest args)
  "Signal an error, making error message by passing all args to `format'.
This error is not continuable: you cannot continue execution after the
error using the debugger `r' command.  See also `cerror'."
  (while t
    (apply 'cerror args)))

(defun cerror (&rest args)
  "Like `error' but signals a continuable error."
  (signal 'error (list (apply 'format args))))

(defmacro check-argument-type (predicate argument)
  "Check that ARGUMENT satisfies PREDICATE.
If not, signal a continuable `wrong-type-argument' error until the
returned value satifies PREDICATE, and assign the returned value
to ARGUMENT."
  `(if (not (,(eval predicate) ,argument))
       (setq ,argument
         (wrong-type-argument ,predicate ,argument))))

(defmacro save-current-buffer (&rest forms)
  "Restore the current buffer setting after executing FORMS.
Does not restore the values of point and mark.
See also: `save-excursion'."
  ;; by [e-mail]
  (` (let ((_cur_buf_ (current-buffer)))
       (unwind-protect
       (progn (,@ forms))
     (set-buffer _cur_buf_)))))

(defmacro eval-in-buffer (buffer &rest forms)
  "Evaluate FORMS in BUFFER.
See also: `save-current-buffer' and `save-excursion'."
  ;; by [e-mail]
  (` (save-current-buffer
      (set-buffer (, buffer))
      (,@ forms))))

;;; The real defn is in abbrev.el but some early callers
;;;  (eg lisp-mode-abbrev-table) want this before abbrev.el is loaded...

(if (not (fboundp 'define-abbrev-table))
    (progn
      (setq abbrev-table-name-list '())
      (fset 'define-abbrev-table (function (lambda (name defs)
                                   ;; These are fixed-up when abbrev.el loads.
                                   (setq abbrev-table-name-list
                                         (cons (cons name defs)
                                               abbrev-table-name-list)))))))

(defun functionp (obj)
  "Returns t if OBJ is a function, nil otherwise."
  (cond
   ((symbolp obj) (fboundp obj))
   ((subrp obj))
   ((compiled-function-p obj))
   ((consp obj)
    (if (eq (car obj) 'lambda) (listp (car (cdr obj)))))
   (t nil)))

(defun add-to-list (list-var element)
  "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
If you want to use `add-to-list' on a variable that is not defined
until a certain package is loaded, you should put the call to `add-to-list'
into a hook function that will be run only after loading the package.
Major mode hooks are one thing which can do the job."
  (or (member element (symbol-value list-var))
      (set list-var (cons element (symbol-value list-var)))))

;; This was not present before.  I think Jamie had some objections
;; to this, so I'm leaving this undefined for now. --ben

;;; The objection is this: there is more than one way to load the same file.
;;; "foo", "foo.elc", "foo.el", and "/some/path/foo.elc" are all differrent
;;; ways to load the exact same code.  `eval-after-load' is too stupid to
;;; deal with this sort of thing.  If this sort of feature is desired, then
;;; it should work off of a hook on `provide'.  Features are unique and
;;; the arguments to (load) are not.  --Stig

;;;; Specifying things to do after certain files are loaded.

;(defun eval-after-load (file form)
;  "Arrange that, if FILE is ever loaded, FORM will be run at that time.
;This makes or adds to an entry on `after-load-alist'.
;It does nothing if FORM is already on the list for FILE.
;FILE should be the name of a library, with no directory name."
;  (or (assoc file after-load-alist)
;      (setq after-load-alist (cons (list file) after-load-alist)))
;  (let ((elt (assoc file after-load-alist)))
;    (or (member form (cdr elt))
;    (nconc elt (list form))))
;  form)
;
;(defun eval-next-after-load (file)
;  "Read the following input sexp, and run it whenever FILE is loaded.
;This makes or adds to an entry on `after-load-alist'.
;FILE should be the name of a library, with no directory name."
;  (eval-after-load file (read)))

; alternate names (not obsolete)
(if (not (fboundp 'mod)) (define-function 'mod '%))
(define-function 'move-marker 'set-marker)
(define-function 'beep 'ding) ;preserve lingual purtity
(define-function 'indent-to-column 'indent-to)
(define-function 'backward-delete-char 'delete-backward-char)
(define-function 'search-forward-regexp (symbol-function 're-search-forward))
(define-function 'search-backward-regexp (symbol-function 're-search-backward))
(define-function 'remove-directory 'delete-directory)
(define-function 'set-match-data 'store-match-data)
(define-function 'send-string-to-terminal 'external-debugging-output)
(define-function 'buffer-string 'buffer-substring)